home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / defstruct.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1987-06-04  |  25.4 KB  |  607 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    DEFSTRUCT.LSP
  6. ;;;;
  7. ;;;;        The structure routines.
  8.  
  9.  
  10. (in-package 'lisp)
  11. (export 'defstruct)
  12.  
  13.  
  14. (in-package 'system)
  15.  
  16.  
  17. (proclaim '(optimize (safety 2) (space 3)))
  18.  
  19.  
  20. (defun make-access-function (name conc-name type named
  21.                              slot-name default-init slot-type read-only
  22.                              offset)
  23.   (declare (ignore named default-init slot-type))
  24.   (let ((access-function
  25.          (intern (si:string-concatenate (string conc-name)
  26.                                         (string slot-name)))))
  27.     (cond ((null type)
  28.            ;; If TYPE is NIL,
  29.            ;;  the slot is at the offset in the structure-body,
  30.            ;;  which is just a list in this implementation.
  31.            (list* `(defun ,access-function (x)
  32.                           (si:structure-ref x ',name ,offset))
  33.                   `(si:putprop ',access-function ',(cons name offset)
  34.                                'structure-access)
  35.                   (if (not read-only)
  36.                      ;; The DEFSETF form is made only when READ-ONLY is NIL.
  37.                      (list `(defsetf ,access-function (x) (v)
  38.                               `(si:structure-set ,x ,'',name ,,offset ,v)))
  39.                      (list `(remprop ',access-function 'setf-update-fn)
  40.                            `(remprop ',access-function 'setf-lambda)
  41.                            `(remprop ',access-function
  42.                                      'setf-documentation)))))
  43.           ((or (eq type 'vector)
  44.                (and (consp type)
  45.                     (eq (car type) 'vector)))
  46.            ;; If TYPE is VECTOR or (VECTOR ... ), ELT is used.
  47.            (list* `(defun ,access-function (x) (elt x ,offset))
  48.                   `(si:putprop ',access-function ',(cons 'vector offset)
  49.                                'structure-access)
  50.                  (if (not read-only)
  51.                      (list `(defsetf ,access-function (x) (v)
  52.                               `(si:elt-set ,x ,,offset ,v)))
  53.                      ;; Removing the DEFSETF definitions.
  54.                      ;; This code is implementation-dependent.
  55.                      (list `(remprop ',access-function 'setf-update-fn)
  56.                            `(remprop ',access-function 'setf-lambda)
  57.                            `(remprop ',access-function
  58.                                      'setf-documentation)))))
  59.           ((eq type 'list)
  60.            ;; If TYPE is LIST, NTH is used.
  61.            (list* `(defun ,access-function (x) (si:list-nth ,offset x))
  62.                   `(si:putprop ',access-function ',(cons 'list offset)
  63.                                'structure-access)
  64.                  (if (not read-only)
  65.                      (list `(defsetf ,access-function (x) (v)
  66.                               `(si:rplaca-nthcdr ,x ,,offset ,v)))
  67.                      (list `(remprop ',access-function 'setf-update-fn)
  68.                            `(remprop ',access-function 'setf-lambda)
  69.                            `(remprop ',access-function
  70.                                      'setf-documentation)))))
  71.           ((error "~S is an illegal structure type." type)))))
  72.  
  73.  
  74. (defun make-constructor (name constructor type named
  75.                          slot-descriptions)
  76.   (declare (ignore named))
  77.   (let ((slot-names
  78.          ;; Collect the slot-names.
  79.          (mapcar #'(lambda (x)
  80.                      (cond ((null x)
  81.                             ;; If the slot-description is NIL,
  82.                             ;;  it is in the padding of initial-offset.
  83.                             nil)
  84.                            ((null (car x))
  85.                             ;; If the slot name is NIL,
  86.                             ;;  it is the structure name.
  87.                             ;;  This is for typed structures with names.
  88.                             (list 'quote (cadr x)))
  89.                            (t (car x))))
  90.                  slot-descriptions))
  91.         (keys
  92.          ;; Make the keyword parameters.
  93.          (mapcan #'(lambda (x)
  94.                      (cond ((null x) nil)
  95.                            ((null (car x)) nil)
  96.                            ((null (cadr x)) (list (car x)))
  97.                            (t (list (list  (car x) (cadr x))))))
  98.                  slot-descriptions)))
  99.     (cond ((consp constructor)
  100.            ;; The case for a BOA constructor.
  101.            ;; Dirty code!!
  102.            ;; We must add an initial value for an optional parameter,
  103.            ;;  if the default value is not specified
  104.            ;;  in the given parameter list and yet the initial value
  105.            ;;  is supplied in the slot description.
  106.            (do ((a (cadr constructor) (cdr a)) (l nil) (vs nil))
  107.                ((endp a)
  108.                 ;; Add those options that do not appear in the parameter list
  109.                 ;;  as auxiliary paramters.
  110.                 ;; The parameters are accumulated in the variable VS.
  111.                 (setq keys
  112.                       (nreconc (cons '&aux l)
  113.                                (mapcan #'(lambda (k)
  114.                                            (if (member (if (atom k) k (car k))
  115.                                                        vs)
  116.                                                nil
  117.                                                (list k)))
  118.                                        keys))))
  119.              ;; Skip until &OPTIONAL appears.
  120.              (cond ((eq (car a) '&optional)
  121.                     (setq l (cons '&optional l))
  122.                     (do ((aa (cdr a) (cdr aa)) (ov) (y))
  123.                         ((endp aa)
  124.                          ;; Add those options that do not appear in the
  125.                          ;;  parameter list.
  126.                          (setq keys
  127.                                (nreconc (cons '&aux l)
  128.                                         (mapcan #'(lambda (k)
  129.                                                     (if (member (if (atom k)
  130.                                                                     k
  131.                                                                     (car k))
  132.                                                                 vs)
  133.                                                         nil
  134.                                                         (list k)))
  135.                                                 keys)))
  136.                          (return nil))
  137.                       (when (member (car aa) lambda-list-keywords)
  138.                             (when (eq (car aa) '&rest)
  139.                                   ;; &REST is found.
  140.                                   (setq l (cons '&rest l))
  141.                                   (setq aa (cdr aa))
  142.                                   (unless (and (not (endp aa))
  143.                                                (symbolp (car aa)))
  144.                                           (illegal-boa))
  145.                                   (setq vs (cons (car aa) vs))
  146.                                   (setq l (cons (car aa) l))
  147.                                   (setq aa (cdr aa))
  148.                                   (when (endp aa)
  149.                                         (setq keys
  150.                                               (nreconc
  151.                                                (cons '&aux l)
  152.                                                (mapcan
  153.                                                 #'(lambda (k)
  154.                                                     (if (member (if (atom k)
  155.                                                                     k
  156.                                                                     (car k))
  157.                                                                 vs)
  158.                                                         nil
  159.                                                         (list k)))
  160.                                                 keys)))
  161.                                         (return nil)))
  162.                             ;; &AUX should follow.
  163.                             (unless (eq (car aa) '&aux)
  164.                                     (illegal-boa))
  165.                             (setq l (cons '&aux l))
  166.                             (do ((aaa (cdr aa) (cdr aaa)))
  167.                                 ((endp aaa))
  168.                               (setq l (cons (car aaa) l))
  169.                               (cond ((and (atom (car aaa))
  170.                                           (symbolp (car aaa)))
  171.                                      (setq vs (cons (car aaa) vs)))
  172.                                     ((and (symbolp (caar aaa))
  173.                                           (or (endp (cdar aaa))
  174.                                               (endp (cddar aaa))))
  175.                                      (setq vs (cons (caar aaa) vs)))
  176.                                     (t (illegal-boa))))
  177.                             ;; End of the parameter list.
  178.                             (setq keys
  179.                                   (nreconc l
  180.                                            (mapcan
  181.                                             #'(lambda (k)
  182.                                                 (if (member (if (atom k)
  183.                                                                 k
  184.                                                                 (car k))
  185.                                                             vs)
  186.                                                     nil
  187.                                                     (list k)))
  188.                                             keys)))
  189.                             (return nil))
  190.                       ;; Checks if the optional paramter without a default
  191.                       ;;  value has a default value in the slot-description.
  192.                       (if (and (cond ((atom (car aa)) (setq ov (car aa)) t)
  193.                                      ((endp (cdar aa)) (setq ov (caar aa)) t)
  194.                                      (t nil))
  195.                                (setq y (member ov
  196.                                                keys
  197.                                                :key
  198.                                                #'(lambda (x)
  199.                                                    (if (consp x)
  200.                                                        ;; With default value.
  201.                                                        (car x))))))
  202.                           ;; If no default value is supplied for
  203.                           ;;  the optional parameter and yet appears
  204.                           ;;  in KEYS with a default value,
  205.                           ;;  then cons the pair to L,
  206.                           (setq l (cons (car y) l))
  207.                           ;;  otherwise cons just the parameter to L.
  208.                           (setq l (cons (car aa) l)))
  209.                       ;; Checks the form of the optional parameter.
  210.                       (cond ((atom (car aa))
  211.                              (unless (symbolp (car aa))
  212.                                      (illegal-boa))
  213.                              (setq vs (cons (car aa) vs)))
  214.                             ((not (symbolp (caar aa)))
  215.                              (illegal-boa))
  216.                             ((or (endp (cdar aa)) (endp (cddar aa)))
  217.                              (setq vs (cons (caar aa) vs)))
  218.                             ((not (symbolp (caddar aa)))
  219.                              (illegal-boa))
  220.                             ((not (endp (cdddar aa)))
  221.                              (illegal-boa))
  222.                             (t
  223.                              (setq vs (cons (caar aa) vs))
  224.                              (setq vs (cons (caddar aa) vs)))))
  225.                     ;; RETURN from the outside DO.
  226.                     (return nil))
  227.                    (t
  228.                     (unless (symbolp (car a))
  229.                             (illegal-boa))
  230.                     (setq l (cons (car a) l))
  231.                     (setq vs (cons (car a) vs)))))
  232.            (setq constructor (car constructor)))
  233.           (t
  234.            ;; If not a BOA constructor, just cons &KEY.
  235.            (setq keys (cons '&key keys))))
  236.     (cond ((null type)
  237.            `(defun ,constructor ,keys
  238.               (si:make-structure ',name ,@slot-names)))
  239.           ((or (eq type 'vector)
  240.                (and (consp type) (eq (car type) 'vector)))
  241.            `(defun ,constructor ,keys
  242.               (vector ,@slot-names)))
  243.           ((eq type 'list)
  244.            `(defun ,constructor ,keys
  245.               (list ,@slot-names)))
  246.           ((error "~S is an illegal structure type" type)))))
  247.  
  248.  
  249. (defun illegal-boa ()
  250.   (error "An illegal BOA constructor."))
  251.  
  252.  
  253. (defun make-copier (name copier type named)
  254.   (declare (ignore named))
  255.   (cond ((null type)
  256.          `(defun ,copier (x)
  257.                  (si:copy-structure x ',name)))
  258.         ((or (eq type 'vector)
  259.              (and (consp type) (eq (car type) 'vector)))
  260.          `(defun ,copier (x) (copy-seq x)))
  261.         ((eq type 'list)
  262.          `(defun ,copier (x) (copy-list x)))
  263.         ((error "~S is an illegal structure type." type))))
  264.  
  265.  
  266. (defun make-predicate (name predicate type named name-offset)
  267.   (cond ((null type)
  268.          ;; If TYPE is NIL, the predicate searches the link
  269.          ;;  of structure-include, until there is no included structure.
  270.          `(defun ,predicate (x)
  271.             (and (si:structurep x)
  272.                  (do ((n (si:structure-name x)))
  273.                      ((null n) nil)
  274.                    (when (eq n ',name) (return t))
  275.                    (setq n (get n 'structure-include))))))
  276.         ((or (eq type 'vector)
  277.              (and (consp type) (eq (car type) 'vector)))
  278.          ;; The name is at the NAME-OFFSET in the vector.
  279.          (unless named (error "The structure should be named."))
  280.          `(defun ,predicate (x)
  281.             (and (vectorp x)
  282.                  (> (length x) ,name-offset)
  283.                  (eq (elt x ,name-offset) ',name))))
  284.         ((eq type 'list)
  285.          ;; The name is at the NAME-OFFSET in the list.
  286.          (unless named (error "The structure should be named."))
  287.          (if (= name-offset 0)
  288.              `(defun ,predicate (x)
  289.                      (and (consp x)
  290.                           (eq (car x) ',name)))
  291.              `(defun ,predicate (x)
  292.                      (do ((i ,name-offset (1- i))
  293.                           (y x (cdr y)))
  294.                          ((= i 0) (and (consp y) (eq (car y) ',name)))
  295.                        (unless (consp y) (return nil))))))
  296.         ((error "~S is an illegal structure type."))))
  297.  
  298.  
  299. ;;; PARSE-SLOT-DESCRIPTION parses the given slot-description
  300. ;;;  and returns a list of the form:
  301. ;;;        (slot-name default-init slot-type read-only offset)
  302.  
  303. (defun parse-slot-description (slot-description offset)
  304.   (let (slot-name default-init slot-type read-only)
  305.     (cond ((atom slot-description)
  306.            (setq slot-name slot-description))
  307.           ((endp (cdr slot-description))
  308.            (setq slot-name (car slot-description)))
  309.           (t
  310.            (setq slot-name (car slot-description))
  311.            (setq default-init (cadr slot-description))
  312.            (do ((os (cddr slot-description) (cddr os)) (o) (v))
  313.                ((endp os))
  314.              (setq o (car os))
  315.              (when (endp (cdr os))
  316.                    (error "~S is an illegal structure slot option."
  317.                           os))
  318.              (setq v (cadr os))
  319.              (case o
  320.                (:type (setq slot-type v))
  321.                (:read-only (setq read-only v))
  322.                (t
  323.                 (error "~S is an illegal structure slot option."
  324.                          os))))))
  325.     (list slot-name default-init slot-type read-only offset)))
  326.  
  327.  
  328. ;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
  329. ;;;  with the new descriptions which are specified in the
  330. ;;;  :include defstruct option.
  331.  
  332. (defun overwrite-slot-descriptions (news olds)
  333.   (if (null olds)
  334.       nil
  335.       (let ((sds (member (caar olds) news :key #'car)))
  336.         (cond (sds
  337.                (when (and (null (cadddr (car sds)))
  338.                           (cadddr (car olds)))
  339.                      ;; If read-only is true in the old
  340.                      ;;  and false in the new, signal an error.
  341.                      (error "~S is an illegal include slot-description."
  342.                             sds))
  343.                (cons (list (caar sds)
  344.                            (cadar sds)
  345.                            (caddar sds)
  346.                            (cadddr (car sds))
  347.                            ;; The offset if from the old.
  348.                            (car (cddddr (car olds))))
  349.                      (overwrite-slot-descriptions news (cdr olds))))
  350.               (t
  351.                (cons (car olds)
  352.                      (overwrite-slot-descriptions news (cdr olds))))))))
  353.  
  354.  
  355. ;;; The DEFSTRUCT macro.
  356.  
  357. (defmacro defstruct (name &rest slots)
  358.   (let ((slot-descriptions slots)
  359.         options
  360.         conc-name
  361.         constructors default-constructor no-constructor
  362.         copier
  363.         predicate predicate-specified
  364.         include
  365.         print-function type named initial-offset
  366.         offset name-offset
  367.         documentation)
  368.  
  369.     (when (consp name)
  370.           ;; The defstruct options are supplied.
  371.           (setq options (cdr name))
  372.           (setq name (car name)))
  373.  
  374.     ;; The default conc-name.
  375.     (setq conc-name (si:string-concatenate (string name) "-"))
  376.  
  377.     ;; The default constructor.
  378.     (setq default-constructor
  379.           (intern (si:string-concatenate "MAKE-" (string name))))
  380.  
  381.     ;; The default copier and predicate.
  382.     (setq copier
  383.           (intern (si:string-concatenate "COPY-" (string name)))
  384.           predicate
  385.           (intern (si:string-concatenate (string name) "-P")))
  386.  
  387.     ;; Parse the defstruct options.
  388.     (do ((os options (cdr os)) (o) (v))
  389.         ((endp os))
  390.       (cond ((and (consp (car os)) (not (endp (cdar os))))
  391.              (setq o (caar os) v (cadar os))
  392.              (case o
  393.                (:conc-name
  394.                 (if (null v)
  395.                     (setq conc-name "")
  396.                     (setq conc-name v)))
  397.                (:constructor
  398.                 (if (null v)
  399.                     (setq no-constructor t)
  400.                     (if (endp (cddar os))
  401.                         (setq constructors (cons v constructors))
  402.                         (setq constructors (cons (cdar os) constructors)))))
  403.                (:copier (setq copier v))
  404.                (:predicate
  405.                 (setq predicate v)
  406.                 (setq predicate-specified t))
  407.                (:include
  408.                 (setq include (cdar os))
  409.                 (unless (get v 'is-a-structure)
  410.                         (error "~S is an illegal included structure." v)))
  411.                (:print-function (setq print-function v))
  412.                (:type (setq type v))
  413.                (:initial-offset (setq initial-offset v))
  414.                (t (error "~S is an illegal defstruct option." o))))
  415.             (t
  416.              (if (consp (car os))
  417.                  (setq o (caar os))
  418.                  (setq o (car os)))
  419.              (case o
  420.                (:constructor
  421.                 (setq constructors
  422.                       (cons default-constructor constructors)))
  423.                ((:conc-name :copier :predicate :print-function))
  424.                (:named (setq named t))
  425.                (t (error "~S is an illegal defstruct option." o))))))
  426.  
  427.     ;; Skip the documentation string.
  428.     (when (and (not (endp slot-descriptions))
  429.                (stringp (car slot-descriptions)))
  430.           (setq documentation (car slot-descriptions))
  431.           (setq slot-descriptions (cdr slot-descriptions)))
  432.     
  433.     ;; Check the include option.
  434.     (when include
  435.           (unless (equal type (get (car include) 'structure-type))
  436.                   (error "~S is an illegal structure include."
  437.                          (car include))))
  438.  
  439.     ;; Set OFFSET.
  440.     (cond ((null include)
  441.            (setq offset 0))
  442.           (t
  443.            (setq offset (get (car include) 'structure-offset))))
  444.  
  445.     ;; Increment OFFSET.
  446.     (when (and type initial-offset)
  447.           (setq offset (+ offset initial-offset)))
  448.     (when (and type named)
  449.           (setq name-offset offset)
  450.           (setq offset (1+ offset)))
  451.  
  452.     ;; Parse slot-descriptions, incrementing OFFSET for each one.
  453.     (do ((ds slot-descriptions (cdr ds))
  454.          (sds nil))
  455.         ((endp ds)
  456.          (setq slot-descriptions (nreverse sds)))
  457.       (setq sds (cons (parse-slot-description (car ds) offset) sds))
  458.       (setq offset (1+ offset)))
  459.  
  460.     ;; If TYPE is non-NIL and structure is named,
  461.     ;;  add the slot for the structure-name to the slot-descriptions.
  462.     (when (and type named)
  463.           (setq slot-descriptions
  464.                 (cons (list nil name) slot-descriptions)))
  465.  
  466.     ;; Pad the slot-descriptions with the initial-offset number of NILs.
  467.     (when (and type initial-offset)
  468.           (setq slot-descriptions
  469.                 (append (make-list initial-offset) slot-descriptions)))
  470.  
  471.     ;; Append the slot-descriptions of the included structure.
  472.     ;; The slot-descriptions in the include option are also counted.
  473.     (cond ((null include))
  474.           ((endp (cdr include))
  475.            (setq slot-descriptions
  476.                  (append (get (car include) 'structure-slot-descriptions)
  477.                          slot-descriptions)))
  478.           (t
  479.            (setq slot-descriptions
  480.                  (append (overwrite-slot-descriptions
  481.                           (mapcar #'(lambda (sd)
  482.                                       (parse-slot-description sd 0))
  483.                                   (cdr include))
  484.                           (get (car include)
  485.                                'structure-slot-descriptions))
  486.                          slot-descriptions))))
  487.  
  488.     (cond (no-constructor
  489.            ;; If a constructor option is NIL,
  490.            ;;  no constructor should have been specified.
  491.            (when constructors
  492.                  (error "Contradictory constructor options.")))
  493.           ((null constructors)
  494.            ;; If no constructor is specified,
  495.            ;;  the default-constructor is made.
  496.            (setq constructors (list default-constructor))))
  497.  
  498.     ;; Check the named option and set the predicate.
  499.     (when (and type (not named))
  500.           (when predicate-specified
  501.                 (error "~S is an illegal structure predicate."
  502.                        predicate))
  503.           (setq predicate nil))
  504.  
  505.     (when include (setq include (car include)))
  506.  
  507.     ;; Check the print-function.
  508.     (when (and print-function type)
  509.           (error "An print function is supplied to a typed structure."))
  510.  
  511.     `(progn (si:putprop ',name
  512.                         '(defstruct ,name ,@slots)
  513.                         'defstruct-form)
  514.             (si:putprop ',name t 'is-a-structure)
  515.             (si:putprop ',name
  516.                         ',slot-descriptions
  517.                         'structure-slot-descriptions)
  518.             (si:putprop ',name ',include 'structure-include)
  519.             (si:putprop ',name
  520.                         ',print-function
  521.                         'structure-print-function)
  522.             (si:putprop ',name ',type 'structure-type)
  523.             (si:putprop ',name ',named 'structure-named)
  524.             ,@(mapcan #'(lambda (x)
  525.                           (if (and x (car x))
  526.                               (apply #'make-access-function
  527.                                      name conc-name type named
  528.                                      x)))
  529.                       slot-descriptions)            
  530.             (si:putprop ',name ,offset 'structure-offset)
  531.             ,@(mapcar #'(lambda (constructor)
  532.                           (make-constructor name constructor type named
  533.                                                   slot-descriptions))
  534.                       constructors)
  535.             (si:putprop ',name ',constructors 'structure-constructors)
  536.             ,@(if copier
  537.                   (list (make-copier name copier type named)))
  538.             ,@(if predicate
  539.                   (list (make-predicate name predicate type named
  540.                                         name-offset)))
  541.             (si:putprop ',name ,documentation 'structure-documentation)
  542.             ',name)))
  543.  
  544.  
  545. ;;; The #S reader.
  546.  
  547. (defun sharp-s-reader (stream subchar arg)
  548.   (declare (ignore subchar))
  549.   (when (and arg (null *read-suppress*))
  550.         (error "An extra argument was supplied for the #S readmacro."))
  551.   (let ((l (read stream)))
  552.     (unless (get (car l) 'is-a-structure)
  553.             (error "~S is not a structure." (car l)))
  554.     ;; Intern keywords in the keyword package.
  555.     (do ((ll (cdr l) (cddr ll)))
  556.         ((endp ll)
  557.          ;; Find an appropriate construtor.
  558.          (do ((cs (get (car l) 'structure-constructors) (cdr cs)))
  559.              ((endp cs)
  560.               (error "The structure ~S has no structure constructor."
  561.                      (car l)))
  562.            (when (symbolp (car cs))
  563.                  (return (apply (car cs) (cdr l))))))
  564.       (rplaca ll (intern (string (car ll)) 'keyword)))))
  565.  
  566.  
  567. ;; Set the dispatch macro.
  568. (set-dispatch-macro-character #\# #\s 'sharp-s-reader)
  569. (set-dispatch-macro-character #\# #\S 'sharp-s-reader)
  570.  
  571.  
  572. ;; Examples from Common Lisp Reference Manual.
  573.  
  574. #|
  575. (defstruct ship
  576.   x-position
  577.   y-position
  578.   x-velocity
  579.   y-velocity
  580.   mass)
  581.  
  582. (defstruct person name age sex)
  583.  
  584. (defstruct (astronaut (:include person (age 45))
  585.                       (:conc-name astro-))
  586.   helmet-size
  587.   (favorite-beverage 'tang))
  588.  
  589. (defstruct (foo (:constructor create-foo (a
  590.                                           &optional b (c 'sea)
  591.                                           &rest d
  592.                                           &aux e (f 'eff))))
  593.   a (b 'bee) c d e f)
  594.  
  595. (defstruct (binop (:type list) :named (:initial-offset 2))
  596.   (operator '?)
  597.   operand-1
  598.   operand-2)
  599.  
  600. (defstruct (annotated-binop (:type list)
  601.                             (:initial-offset 3)
  602.                             (:include binop))
  603.   commutative
  604.   associative
  605.   identity)
  606. |#
  607.